home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / cmpnew / cmpspecial.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  5KB  |  132 lines
  1. ;;; CMPSPECIAL  Miscellaneous special forms.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (si:putprop 'quote 'c1quote 'c1special)
  10. (si:putprop 'function 'c1function 'c1special)
  11. (si:putprop 'function 'c2function 'c2)
  12. (si:putprop 'the 'c1the 'c1special)
  13. (si:putprop 'eval-when 'c1eval-when 'c1special)
  14. (si:putprop 'declare 'c1declare 'c1special)
  15. (si:putprop 'compiler-let 'c1compiler-let 'c1special)
  16. (si:putprop 'compiler-let 'c2compiler-let 'c2)
  17.  
  18. (defun c1quote (args)
  19.   (when (endp args) (too-few-args 'quote 1 0))
  20.   (unless (endp (cdr args)) (too-many-args 'quote 1 (length args)))
  21.   (c1constant-value (car args) t)
  22.   )
  23.  
  24. (defun c1eval-when (args)
  25.   (when (endp args) (too-few-args 'eval-when 1 0))
  26.   (dolist** (situation (car args) (c1nil))
  27.     (case situation
  28.           (eval (return-from c1eval-when (c1progn (cdr args))))
  29.           ((load compile))
  30.           (otherwise
  31.            (cmperr "The situation ~s is illegal." situation))))
  32.   )
  33.  
  34. (defun c1declare (args)
  35.   (cmperr "The declaration ~s was found in a bad place." (cons 'declare args))
  36.   )
  37.  
  38. (defun c1the (args &aux info form type)
  39.   (when (or (endp args) (endp (cdr args)))
  40.         (too-few-args 'the 2 (length args)))
  41.   (unless (endp (cddr args))
  42.           (too-many-args 'the 2 (length args)))
  43.   (setq form (c1expr (cadr args)))
  44.   (setq info (copy-info (cadr form)))
  45.   (setq type (type-and (type-filter (car args)) (info-type info)))
  46.   (when (null type)
  47.         (cmpwarn "Type mismatch was found in ~s." (cons 'the args)))
  48.   (setf (info-type info) type)
  49.   (list* (car form) info (cddr form))
  50.   )
  51.  
  52. (defun c1compiler-let (args &aux (symbols nil) (values nil))
  53.   (when (endp args) (too-few-args 'compiler-let 1 0))
  54.   (dolist** (spec (car args))
  55.     (cond ((consp spec)
  56.            (cmpck (not (and (symbolp (car spec))
  57.                             (or (endp (cdr spec))
  58.                                 (endp (cddr spec)))))
  59.                   "The variable binding ~s is illegal." spec)
  60.            (push (car spec) symbols)
  61.            (push (if (endp (cdr spec)) nil (eval (cadr spec))) values))
  62.           ((symbolp spec)
  63.            (push spec symbols)
  64.            (push nil values))
  65.           (t (cmperr "The variable binding ~s is illegal." spec))))
  66.   (setq symbols (reverse symbols))
  67.   (setq values (reverse values))
  68.   (setq args (progv symbols values (c1progn (cdr args))))
  69.   (list 'compiler-let (cadr args) symbols values args)
  70.   )
  71.  
  72. (defun c2compiler-let (symbols values body)
  73.   (progv symbols values (c2expr body)))
  74.  
  75. (defun c1function (args &aux fd)
  76.   (when (endp args) (too-few-args 'function 1 0))
  77.   (unless (endp (cdr args)) (too-many-args 'function 1 (length args)))
  78.   (let ((fun (car args)))
  79.        (cond ((symbolp fun)
  80.               (cond ((and (setq fd (c1local-closure fun))
  81.                           (eq (car fd) 'call-local))
  82.                      (list 'function *info* fd))
  83.                     (t (let ((info (make-info
  84.                                     :sp-change
  85.                                     (null (get fun 'no-sp-change)))))
  86.                             (list 'function info (list 'call-global info fun))
  87.                             ))))
  88.              ((and (consp fun) (eq (car fun) 'lambda))
  89.               (cmpck (endp (cdr fun))
  90.                      "The lambda expression ~s is illegal." fun)
  91.               (let ((*vars* (cons 'cb *vars*))
  92.                     (*funs* (cons 'cb *funs*))
  93.                     (*blocks* (cons 'cb *blocks*))
  94.                     (*tags* (cons 'cb *tags*)))
  95.                    (setq fun (c1lambda-expr (cdr fun)))
  96.                    (list 'function (cadr fun) fun)))
  97.              (t (cmperr "The function ~s is illegal." fun))))
  98.   )
  99.  
  100. (defun c2function (funob)
  101.   (case (car funob)
  102.         (call-global
  103.          (unwind-exit (list 'symbol-function (add-symbol (caddr funob)))))
  104.         (call-local
  105.          (if (cadddr funob)
  106.              (unwind-exit (list 'ccb-vs (fun-ref-ccb (caddr funob))))
  107.              (unwind-exit (list 'vs* (fun-ref (caddr funob))))))
  108.         (t
  109.          ;;; Lambda closure.
  110.          (let ((fun (make-fun :name 'closure :cfun (next-cfun))))
  111.               (push (list 'closure (if (null *clink*) nil (cons 0 0))
  112.                           *ccb-vs* fun funob)
  113.                     *local-funs*)
  114.               (push fun *closures*)
  115.               (unwind-exit (list 'make-cclosure (fun-cfun fun) *clink*)))
  116.              ))
  117.   )
  118.  
  119. (si:putprop 'symbol-function 'wt-symbol-function 'wt-loc)
  120. (si:putprop 'make-cclosure 'wt-make-cclosure 'wt-loc)
  121.  
  122. (defun wt-symbol-function (vv)
  123.        (if *safe-compile*
  124.            (wt "symbol_function(VV[" vv "])")
  125.            (wt "(VV[" vv "]->s.s_gfdef)")))
  126.  
  127. (defun wt-make-cclosure (cfun clink)
  128.        (wt-nl "make_cclosure(LC" cfun ",Cnil,")
  129.        (wt-clink clink)
  130.        (wt ",Cdata,Cstart,Csize)"))
  131.  
  132.